home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload Trio 2
/
Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO
/
dir44
/
advsrc.zip
/
DB.FOR
< prev
next >
Wrap
Text File
|
1993-07-29
|
27KB
|
894 lines
C Adventure Binary Data Base Generator From ASCII File--storage 2
c Written for MS DOS PDS FORTRAN v5.10
c by Paul Muñoz-Colman, FunStuff Software
c 27 Mar 1993
c 12 August 1985
C
$NODEBUG
$notstrict
$storage: 2
IMPLICIT INTEGER*2 (A-Z)
COMMON /TXTCOM/ RTEXT
COMMON /BLKCOM/ BLKLIN
COMMON /VOCCOM/ KTAB,ATAB,TABSIZ
COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
COMMON /MTXCOM/ MTEXT
COMMON /PTXCOM/ PTEXT
COMMON /ABBCOM/ ABB
COMMON /concom/ COND
COMMON /LOCCOM/ LOC
COMMON /PROCOM/ prop, lamp
COMMON /WIZCOM/ WKDAY,WKEND,HOLID,HBEGIN,HEND,HNAME,
1 SHORT,MAGIC,MAGNM,LATNCY,SAVED,SAVET,SETUP
COMMON /lincom/ LINES
CHARACTER*2 LINES (21150),CLINES
CHARACTER*4 WD1,WD2,IZ,BL,ATAB(295),TK(20)
CHARACTER*12 FNAME
INTEGER*4 TRAVEL(745),ITK(20),IZZ,IBL,ILINES,newloc,klong,llong
integer*4 kklong,linuse,kk,linsiz,ran
DIMENSION KTAB(295),RTEXT(205)
DIMENSION LTEXT(150),STEXT(150),KEY(150),COND(150),ABB(150),
1 ATLOC(150)
DIMENSION PLAC(100),PLACE(100),FIXD(100),FIXED(100),LINK(200),
1 PTEXT(100),PROP(100)
DIMENSION ACTSPK(35)
DIMENSION CTEXT(12),CVAL(12)
DIMENSION HINTLC(20),HINTED(20),HINTS(20,4)
DIMENSION MTEXT(35)
DIMENSION DSEEN(6),DLOC(6),ODLOC(6),HNAME(4)
INTEGER*2 IDONDX
C
EQUIVALENCE(IZ,IZZ),(BL,IBL),(TK,ITK),(CLINES,ILINES)
DATA LINSIZ/21150/,TRVSIZ/745/,LOCSIZ/150/,
1 VRBSIZ/35/,RTXSIZ/205/,CLSMAX/12/,HNTSIZ/20/,MAGSIZ/35/
DATA BL/' '/,IZZ/0/
C
bitset(l,n)=mod(shift(cond(l),-n),2)
liq2(pbotl)=(1-pbotl)*water+(pbotl/2)*(water+oil)
liqloc(loc)=liq2((mod(cond(loc)/2*2,8)-5)*mod(cond(loc)/4,2)+1)
liq(dummy)=liq2(max0(prop(bottle),-1-prop(bottle)))
c
SETUP = 0
TABSIZ=295
BLKLIN = 1
IF(SETUP.NE.0)GOTO 1100
WRITE (*,1000)
1000 FORMAT(//' IBM PC Adventure Binary Data Base Writer!',//,
. ' Initializing..Please Wait..',//)
DO 1001 I=1,300
IF(I.LE.100)PTEXT(I)=0
IF(I.LE.RTXSIZ)RTEXT(I)=0
IF(I.LE.CLSMAX)CTEXT(I)=0
IF(I.LE.MAGSIZ)MTEXT(I)=0
IF(I.GT.LOCSIZ)GOTO 1001
STEXT(I)=0
LTEXT(I)=0
COND(I)=0
1001 CONTINUE
FNAME='ADVEDAT.ASC'
OPEN (1, FILE=FNAME)
REWIND 1
SETUP=1
LINUSE=1
TRVS=1
CLSSES=1
c start new data section. sect is the section number.
1002 read(1,1003)sect
1003 format(i4)
oldloc=-1
if(sect.gt.11) call bug(9)
c
if (sect .ne. 0) write (*,10031) sect
10031 format (1h ,i2/)
goto(1100,1004,1004,1030,1040,1004,1004,1050,1060,1070,1004,
1 1080),(sect+1)
c (0) (1) (2) (3) (4) (5) (6) (7) (8) (9) (10)
c (11)
c sections 1, 2, 5, 6, 10. read messages and set up pointers.
1004 read(1,1005)loc,(lines(linuse+j),j=1,36)
1005 format(i4,36a2)
c
if(loc.eq.-1)goto 1002
do 1006 k=1,36
kk=linuse+37-k
if(lines(kk).ne.' ')go to 1007
1006 continue
call bug(1)
1007 ilines=kk+1
lines(linuse)=clines
if(loc.eq.oldloc)goto 1020
ilines=-ilines
lines(linuse)=clines
if(sect.eq.10)goto 1012
if(sect.eq.6)goto 1011
if(sect.eq.5)goto 1010
if(sect.eq.1)goto 1008
stext(loc)=linuse
goto 1020
1008 ltext(loc)=linuse
goto 1020
1010 if(loc.gt.0.and.loc.le.100)ptext(loc)=linuse
goto 1020
1011 if(loc.gt.rtxsiz)call bug(6)
rtext(loc)=linuse
goto 1020
1012 ctext(clsses)=linuse
cval(clsses)=loc
clsses=clsses+1
goto 1020
1020 linuse=kk+1
ilines=-1
lines(linuse)=clines
oldloc=loc
if(linuse+36.gt.linsiz)call bug(2)
goto 1004
c the stuff for section 3 is encoded here. each "from-location" gets a
c contiguous section of the "travel" array. each entry in travel is
c newloc*1000 + keyword (from section 4, motion verbs), and is negated if
c this is the last entry for this location. key(n) is the index in travel
c of the first option at location n.
1030 read(1,1031)loc,newloc,(itk(l),l=1,9)
1031 format(i4,10i7)
if(loc.eq.-1)goto 1002
if(key(loc).ne.0)goto 1033
key(loc)=trvs
goto 1035
1033 travel(trvs-1)=-travel(trvs-1)
1035 do 1037 l=1,9
if(itk(l).eq.0)goto 1039
travel(trvs)=newloc*1000+itk(l)
trvs=trvs+1
if(trvs.eq.trvsiz)call bug(3)
1037 continue
1039 travel(trvs-1)=-travel(trvs-1)
goto 1030
c here we read in the vocabulary. ktab(n) is the word number, atab(n) is
c the corresponding word. the -1 at the end of section 4 is left in ktab
c as an end-marker.
c
c
1040 do 1042 tabndx=1,tabsiz
1043 read(1,1041)ktab(tabndx),atab(tabndx)
1041 format(i4,a4)
if(ktab(tabndx).eq.-1)goto 1002
1042 continue
call bug(4)
c read in the initial locations for each object. also the immovability info.
c plac contains initial locations of objects. fixd is -1 for immovable
c objects (including the snake), or = second loc for two-placed objects.
1050 read(1,1031)obj,j,k
if(obj.eq.-1)goto 1002
plac(obj)=j
fixd(obj)=k
goto 1050
c read default message numbers for action verbs, store in actspk.
1060 read(1,1031)verb,j
if(verb.eq.-1)goto 1002
actspk(verb)=j
goto 1060
c read info about available liquids and other conditions, store in cond.
1070 read(1,1031)k,(itk(i),i=1,10)
if(k.eq.-1)goto 1002
do 1071 i=1,10
loc=itk(i)
if(loc.eq.0)goto 1070
if(bitset(loc,k).eq.1)call bug(8)
1071 cond(loc)=cond(loc)+shift(1,k)
goto 1070
c read data for hints.
1080 hntmax=0
1081 read(1,1031)k,(itk(i),i=1,4)
if(k.eq.-1)goto 1002
if(k.lt.0.or.k.gt.hntsiz)call bug(7)
do 1083 i=1,4
1083 hints(k,i)=itk(i)
hntmax=max0(hntmax,k)
goto 1081
c finish constructing internal data format
1100 CLOSE (1)
C HAVING READ IN THE DATABASE, CERTAIN THINGS ARE NOW CONSTRUCTED. PROPS ARE
C SET TO ZERO. WE FINISH SETTING UP COND BY CHECKING FOR FORCED-MOTION TRAVEL
C ENTRIES. THE PLAC AND FIXD ARRAYS ARE USED TO SET UP ATLOC(N) AS THE FIRST
C OBJECT AT LOCATION N, AND LINK(OBJ) AS THE NEXT OBJECT AT THE SAME LOCATION
C AS OBJ. (OBJ>100 INDICATES THAT FIXED(OBJ-100)=LOC; LINK(OBJ) IS STILL THE
C CORRECT LINK TO USE.) ABB IS ZEROED; IT CONTROLS WHETHER THE ABBREVIATED
C DESCRIPTION IS PRINTED. COUNTS MOD 5 UNLESS "LOOK" IS USED.
DO 1101 I=1,100
PLACE(I)=0
PROP(I)=0
LINK(I)=0
1101 LINK(I+100 )=0
DO 1102 I=1,LOCSIZ
ABB(I)=0
IF(LTEXT(I).EQ.0.OR.KEY(I).EQ.0)GOTO 1102
K=KEY(I)
IF(MOD(IABS(TRAVEL(K)),1000).EQ.1)COND(I)=2
1102 ATLOC(I)=0
C SET UP THE ATLOC AND LINK ARRAYS AS DESCRIBED ABOVE. WE'LL USE THE DROP
C SUBOUTINE, WHICH PREFACES NEW OBJECTS ON THE LISTS. SINCE WE WANT THINGS
C IN THE OTHER ORDER, WE'LL RUN THE LOOP BACKWARDS. IF THE OBJECT IS IN TWO
C LOCS, WE DROP IT TWICE. THIS ALSO SETS UP "PLACE" AND "FIXED" AS COPIES OF
C "PLAC" AND "FIXD". ALSO, SINCE TWO-PLACED OBJECTS ARE TYPICALLY BEST
C DESCRIBED LAST, WE'LL DROP THEM FIRST.
DO 1106 I=1,100
K=101-I
IF(FIXD(K).LE.0)GOTO 1106
CALL DROP(K+100,FIXD(K))
CALL DROP(K,PLAC(K))
1106 CONTINUE
DO 1107 I=1,100
K=101-I
FIXED(K)=FIXD(K)
1107 IF(PLAC(K).NE.0.AND.FIXD(K).LE.0)CALL DROP(K,PLAC(K))
C TREASURES, AS NOTED EARLIER, ARE OBJECTS 50 THROUGH MAXTRS (CURRENTLY 79).
C THEIR PROPS ARE INITIALLY -1, AND ARE SET TO 0 THE FIRST TIME THEY ARE
C DESCRIBED. TALLY KEEPS TRACK OF HOW MANY ARE NOT YET FOUND, SO WE KNOW
C WHEN TO CLOSE THE CAVE. TALLY2 COUNTS HOW MANY CAN NEVER BE FOUND (E.G. IF
C LOST BIRD OR BRIDGE).
MAXTRS=79
TALLY=0
TALLY2=0
DO 1200 I=50,MAXTRS
IF(PTEXT(I).NE.0)PROP(I)=-1
1200 TALLY=TALLY-PROP(I)
C CLEAR THE HINT STUFF. HINTLC(I) IS HOW LONG HE'S BEEN AT LOC WITH COND BIT
C I. HINTED(I) IS TRUE IFF HINT I HAS BEEN USED.
DO 1300 I=1,HNTMAX
HINTED(I)=0
1300 HINTLC(I)=0
c define some handy mnemonics. these correspond to object numbers.
keys=vocab('keys',1)
lamp=vocab('lamp',1)
grate=vocab('grat',1)
cage=vocab('cage',1)
rod=vocab('rod ',1)
rod2=rod+1
steps=vocab('step',1)
bird=vocab('bird',1)
door=vocab('door',1)
pillow=vocab('pill',1)
snake=vocab('snak',1)
fissur=vocab('fiss',1)
tablet=vocab('tabl',1)
clam=vocab('clam',1)
oyster=vocab('oyst',1)
magzin=vocab('maga',1)
dwarf=vocab('dwar',1)
knife=vocab('knife',1)
food=vocab('food',1)
bottle=vocab('bott',1)
water=vocab('wate',1)
oil=vocab('oil ',1)
plant=vocab('plan',1)
plant2=plant+1
axe=vocab('axe ',1)
mirror=vocab('mirr',1)
dragon=vocab('drag',1)
chasm=vocab('chas',1)
troll=vocab('trol',1)
troll2=troll+1
bear=vocab('bear',1)
messag=vocab('mess',1)
vend=vocab('vend',1)
batter=vocab('batt',1)
c objects from 50 through whatever are treasures. here are a few.
nugget=vocab('gold',1)
coins=vocab('coins',1)
chest=vocab('chest',1)
eggs=vocab('eggs',1)
tridnt=vocab('trid',1)
vase=vocab('vase',1)
emrald=vocab('emer',1)
pyram=vocab('pyra',1)
pearl=vocab('pear',1)
rug=vocab('rug ',1)
chain=vocab('chai',1)
spices=vocab('spic',1)
c these are motion-verb numbers.
back=vocab('back',0)
look=vocab('look',0)
cave=vocab('cave',0)
null=vocab('null',0)
entrnc=vocab('entr',0)
dprssn=vocab('depr',0)
c and some action verbs.
say=vocab('say ',2)
lock=vocab('lock',2)
throw=vocab('thro',2)
find=vocab('find',2)
invent=vocab('inve',2)
CHLOC=114
CHLOC2=140
DO 1700 I=1,6
1700 DSEEN(I)=0
DFLAG=0
DLOC(1)=19
DLOC(2)=27
DLOC(3)=33
DLOC(4)=44
DLOC(5)=64
DLOC(6)=CHLOC
DALTLC=18
TURNS=0
LMWARN=0
IWEST=0
KNFLOC=0
DETAIL=0
ABBNUM=5
DO 1800 I=1,5
1800 IF(RTEXT(2*I+79).NE.0)MAXDIE=I
NUMDIE=0
HOLDNG=0
DKILL=0
FOOBAR=0
BONUS=0
CLOCK1=30
CLOCK2=50
SAVED=0
CLOSNG=0
PANIC=0
CLOSED=0
GAVEUP=0
SCORNG=0
DO 1998 K=1,LOCSIZ
KK=LOCSIZ+1-K
IF(LTEXT(KK).NE.0)GOTO 1997
1998 CONTINUE
OBJ=0
1997 DO 1996 K=1,100
1996 IF(PTEXT(K).NE.0)OBJ=OBJ+1
DO 1995 K=1,TABNDX
1995 IF(KTAB(K)/1000.EQ.2)VERB=KTAB(K)-2000
DO 1994 K=1,RTXSIZ
J=RTXSIZ+1-K
IF(RTEXT(J).NE.0)GOTO 1993
1994 CONTINUE
1993 DO 1992 K=1,MAGSIZ
I=MAGSIZ+1-K
IF(MTEXT(I).NE.0)GOTO 1991
1992 CONTINUE
1991 K=100
WRITE (*,1999) LINUSE,LINSIZ,TRVS,TRVSIZ,TABNDX,TABSIZ
WRITE (*,19992)KK,LOCSIZ,OBJ,K,VERB,VRBSIZ,J,RTXSIZ,CLSSES,CLSMAX
WRITE (*,19993) HNTMAX,HNTSIZ,I,MAGSIZ
1999 FORMAT (' TABLE SPACE USED:'/
1 ' ',I6,' OF ',I6,' WORDS OF MESSAGES'/
2 ' ',I6,' OF ',I6,' TRAVEL OPTIONS'/
3 ' ',I6,' OF ',I6,' VOCABULARY WORDS'/)
19992 FORMAT ( ' ',I6,' OF ',I6,' LOCATIONS'/
5 ' ',I6,' OF ',I6,' OBJECTS'/
6 ' ',I6,' OF ',I6,' ACTION VERBS'/
7 ' ',I6,' OF ',I6,' RTEXT MESSAGES'/
8 ' ',I6,' OF ',I6,' CLASS MESSAGES'/)
19993 FORMAT ( ' ',I6,' OF ',I6,' HINTS'/
9 ' ',I6,' OF ',I6,' MAGIC MESSAGES'/)
c
c save the data base in array format
c
open (2,file='ad.dat',status='unknown',form='unformatted')
c
write (2) abbnum,axe,back,batter,bear,bird,bonus,bottle,
. cage,cave,chain,chasm,chest,chloc,chloc2,clam,
. clock1,clock2,closed,closng,coins,daltlc,detail,dflag,
. dkill,dloc,door,dprssn,dragon,dseen,dwarf,eggs,
. emrald,entrnc,find,fissur,foobar,food,gaveup,grate
c
write (2) invent,iwest,keys,knfloc,knife,lamp,lmwarn,
. lock,look,magzin,maxdie,maxtrs,messag,mirror,nugget,
. null,numdie,oil,oyster,panic,pearl,pillow,plant,
. plant2,pyram,rod,rod2,rug,saved,say,scorng,
. snake,spices,steps,tablet,tally,tally2,throw,tridnt,
. troll,troll2,turns,vase,vend,water,tabsiz,blklin,oldloc,fixed
c
write (2) linuse,trvs,tabndx,obj,verb,clsses,hntmax,loc,newloc,
. k,j,stext,ltext,ptext,rtext,ctext,cval,key,
. travel,ktab,plac,fixd,actspk,cond,hints,place,prop,link,
. abb,atloc,holdng,hinted,hintlc,kk,i,itk,atab,lines
c
endfile 2
close (2)
1 CONTINUE
C1 DEMO=START(0)
C CALL MOTD(0)
write (*,*) 'Finished'
END
c subroutines and functions
subroutine speak(n)
c print the message which starts at lines(n). precede it with a blank line
c unless blklin is false.
implicit integer*2 (a-z)
common /lincom/ lines
common /txtcom/ rtext
common /blkcom/ blklin
dimension rtext (205)
character*2 lines (21150)
character*2 np,clines
equivalence (clines,ilines)
data np/'>$'/
if(n.eq.0)return
if(lines(n+1).eq.np)return
if(blklin.eq.1) write (*,2)
k=n
1 clines=lines(k)
l=iabs(ilines)-1
k=k+1
write (*, 2) (lines(i),i=k,l)
2 format(' ',36a2)
k=l+1
clines=lines(k)
if(ilines.ge.0) go to 1
return
end
subroutine pspeak(msg,skip)
c find the skip+1st message from msg and print it. msg should be the index of
c the inventory message for object. (inven+n+1 message is prop=n message).
implicit integer*2 (a-z)
common /lincom/ lines
common /txtcom/ rtext
common /ptxcom/ ptext
character*2 lines (21150),clines
dimension rtext(205),ptext(100)
equivalence (clines,ilines)
m=ptext(msg)
if(skip.lt.0)goto 9
do 3 i=1,skip+1
1 clines=lines(m)
m=iabs(ilines)
clines=lines(m)
if(ilines.ge.0) go to 1
3 continue
9 call speak(m)
return
end
subroutine rspeak(i)
c print the i-th "random" message (section 6 of database).
implicit integer*2 (a-z)
common /txtcom/ rtext
dimension rtext(205)
if(i.ne.0)call speak(rtext(i))
return
end
integer*2 function yes(x,y,z)
c call yesx (below) with messages from section 6.
implicit integer*2 (a-z)
yes=yesx(x,y,z)
return
end
integer*2 function yesx(x,y,z)
c print message x, wait for yes/no answer. if yes, print y and leave yea
c true; if no, print z and leave yea false.
implicit integer*2 (a-z)
character*4 reply,junk1,junk2,junk3
1 if(x.ne.0) call rspeak (x)
call getin(reply,junk1,junk2,junk3)
if(reply.eq.'yes '.or.reply.eq.'y ')goto 10
if(reply.eq.'no '.or.reply.eq.'n ')goto 20
write (*,9)
9 format(/' Please answer the question "yes" or "no".')
goto 1
10 yesx=1
if(y.ne.0) call rspeak (y)
return
20 yesx=0
if(z.ne.0) call rspeak (z)
return
end
subroutine a5toa1 (a, b, c, d, chars, leng)
c a & b contain a 1 to 8-character word in a4 format. c & d contain
c another word and/or punctuation. they are unpacked to one character
c per word in the array "chars", with exactly one blank between b & c
c (or none, if c is zero). the index of the last non-blank character
c in chars is returned in leng.
implicit integer*2 (a-z)
integer*4 ic
character *20 aaa
character *4 a,b,c,d,aa(5),cc
character *1 chars(20),raw(20)
equivalence (aaa,aa),(cc,ic)
c do first word until a blank
aa(1) = a
aa(2) = b
call unpack (aaa, raw)
c clear output array and move, counting to first blank
leng=0
do 2 i=1,20
2 chars(i)=' '
do 1 i=1,8
if (raw(i).eq.' ') go to 3
chars(i)=raw(i)
1 leng=i
c leng doesn't include trailing blank
3 cc=c
if(ic.eq.0) go to 99
c second word--ignore leading blanks, stop at trailing one
chars(leng+1)=' '
leng=leng+1
ll=leng
aa(1)=c
aa(2)=d
call unpack (aaa,raw)
c skip leading blank if any
do 4 j=1,8
4 if (raw(j).ne.' ') go to 5
c second word was all blank--fooey
go to 99
c do non-blanks
5 do 6 k=j,8
if (raw(k).eq.' ') go to 99
chars (k-j+1+ll) = raw(k)
6 leng=leng+1
99 return
end
c
integer*2 function vocab(id,init)
c look up id in the vocabulary (atab) and return its "definition" (ktab), or
c -1 if not found. if init is positive, this is an initialization call setting
c up a keyword variable, and not finding it constitutes a bug. it also means
c that only ktab values which taken over 1000 equal init may be considered.
c (thus "steps", which is a motion verb as well as an object, may be located
c as an object.) and it also means the ktab value is taken mod 1000.
implicit integer*2 (a-z)
common /voccom/ ktab,atab,tabsiz
character*4 atab(295),id
dimension ktab(295)
do 1 i=1,tabsiz
if(ktab(i).eq.-1)goto 2
if(init.ge.0.and.ktab(i)/1000.ne.init)goto 1
if(atab(i).eq.id)goto 3
1 continue
10 format(1x,i4,2x,a4)
call bug(21)
2 vocab=-1
if(init.lt.0)return
write (*,10) init, id
call bug(5)
3 vocab=ktab(i)
if(init.ge.0)vocab=mod(vocab,1000)
return
end
subroutine dstroy(object)
c permanently eliminate "object" by moving to a non-existent location.
implicit integer*2 (a-z)
call move(object,0)
return
end
subroutine juggle(object)
c juggle an object by picking it up and putting it down again, the purpose
c being to get the object to the front of the chain of things at its loc.
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
dimension atloc(150),link(200),place( 100),fixed(100)
i=place(object)
call move(object,i)
call move(object+100,j)
return
end
subroutine move(object,where)
c place any object anywhere by picking it up and dropping it. may already be
c toting, in which case the carry is a no-op. mustn't pick up objects which
c are not at any loc, since carry wants to remove objects from atloc chains.
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
dimension atloc(150),link(200),place( 100),fixed(100)
if(object.gt.100)goto 1
from=place(object)
goto 2
1 from=fixed(object-100)
2 if(from.gt.0.and.from.le.300)call carry(object,from)
call drop(object,where)
return
end
integer*2 function put(object,where,pval)
c put is the same as move, except it returns a value used to set up the
c negated prop values for the repository objects.
implicit integer*2 (a-z)
call move(object,where)
put=(-1)-pval
return
end
subroutine carry(object,where)
c start toting an object, removing it from the list of things at its former
c location. incr holdng unless it was already being toted. if object>100
c (moving "fixed" second loc), don't change place or holdng.
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
dimension atloc(150),link(200),place( 100),fixed(100)
if(object.gt.100)goto 5
if(place(object).eq.-1)return
place(object)=-1
holdng=holdng+1
5 if(atloc(where).ne.object)goto 6
atloc(where)=link(object)
return
6 temp=atloc(where)
7 if(link(temp).eq.object)goto 8
temp=link(temp)
goto 7
8 link(temp)=link(object)
return
end
subroutine drop(object,where)
c place an object at a given loc, prefixing it onto the atloc list. decr
c holdng if the object was being toted.
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
dimension atloc(150),link(200),place( 100),fixed(100)
if(object.gt.100)goto 1
if(place(object).eq.-1)holdng=holdng-1
place(object)=where
goto 2
1 fixed(object-100)=where
2 if(where.le.0)return
link(object)=atloc(where)
atloc(where)=object
return
end
c utility routines (shift, bug)
integer*2 function shift (val, dist)
c return val shifted (left if dist>0, else right) dist bits
implicit integer*2 (a-z)
shift=val
if (dist.eq.0) go to 20
idist=iabs(dist)
do 1 i = 1,idist
if (dist.lt.0) shift=shift/2
1 if (dist.gt.0) shift=shift*2
20 return
end
subroutine bug(num)
implicit integer*2 (a-z)
c the following conditions are currently considered fatal bugs. numbers < 20
c are detected while reading the database; the others occur at "run time".
c 0 message line > 72 characters
c 1 null line in message
c 2 too many words of messages
c 3 too many travel options
c 4 too many vocabulary words
c 5 required vocabulary word not found
c 6 too many rtext messages
c 7 too many hints
c 8 location has cond bit being set twice
c 9 invalid section number in database
c 20 special travel (500>l>300) exceeds goto list
c 21 ran off end of vocabulary table
c 22 vocabulary type (n/1000) not between 0 and 3
c 23 intransitive action verb exceeds goto list
c 24 transitive action verb exceeds goto list
c 25 conditional travel entry with no alternative
c 26 location has no travel entries
c 27 hint number exceeds goto list
c 28 invalid month returned by date function
write (*,1) num
1 format (' Fatal error, see source code for interpretation.'/
. ' Probable cause: erroneous info in database.'/
2 ' Error code =',i2/)
pause 'To Exit From Adventure'
end
subroutine getin (word1,word1x,word2,word2x)
c get a command from the adventurer. snarf out the first word, pad it
c with blanks, and return in word1--word1x used for overflow charcters
c 5-8 in case we need to print the whole word back out in an error.
c any number of blanks may follow the word. if a second word appears
c it is returned in word2/word2x, else word2 is set to zero. all are
c converted to lower case for comparison ease (ibm pc version).
implicit integer*2 (a-z)
common /blkcom/ blklin
character*1 s(20), t(20)
character*4 word1, word1x, word2, word2x, w1(5), w2(5), a(5)
character*20 w81, w82, aa, bb
integer*4 iw1, iw1x, iw2, iw2x
equivalence (w1(1),iw1),(w1(2),iw1x),(a,aa)
equivalence (w2(1),iw2),(w2(2),iw2x),(w81,w1),(w82,w2)
if (blklin.eq.1) write (*,1)
1 format (1x)
c give a prompt to make him think we want input
write (*,9)
9 format (' -> ',\)
c
c read twenty characters into a. unpack them into s.
read (*,3) a
3 format (5a4)
bb = aa
call unpack (bb, s)
c translate all to lower case
do 1001 i=1,20
if (ichar(s(i)).lt.65.or.ichar(s(i)).gt.90) go to 1001
s(i)=char(ichar(s(i))+32)
1001 continue
c go through the characters and transfer the first word into t, up
c to eight characters
do 10 i=1,20
10 t(i)=' '
do 11 i=1,8
if (s(i).eq.' ') go to 20
11 t(i)=s(i)
c now repack the characters into w81, equivalent to word1,word1x
20 call pack (w81,t)
word1=w1(1)
word1x=w1(2)
c now find a second word if one exists--clear return words first
iw2=0
iw2x=0
do 30 i=1,20
30 t(i)=' '
do 31 i=1,20
if (s(i).ne.' ') go to 31
go to 32
31 continue
c all characters--fooey
go to 40
c hit first blank after first word--now get first non-blank
32 do 33 j=i,20
if (s(j).eq.' ') go to 33
go to 34
33 continue
c blanked out again
go to 40
c hit beginning of second word--finish it
34 do 35 i=j,20
if (s(i).eq.' ') go to 36
35 t(i-j+1)=s(i)
c now repack word2/2x
36 call pack (w82,t)
40 word2=w2(1)
word2x=w2(2)
return
end
c
subroutine unpack (b, s)
implicit integer*2 (a-z)
c unpack general subroutine
c b 20 character string
c s 20 character*1 singles
character*20 a,b
character*4 aa(5)
integer*4 ia(5)
equivalence (ia,a,aa)
character*1 s(20)
a = b
do 1 k = 1,5
do 1 j = 1,4
s(4*(k-1)+j)=aa(k)
1 if(j.ne.4)ia(k)=ia(k)/256
return
end
c
subroutine pack (b, t)
implicit integer*2 (a-z)
c general pack subroutine--20 characters
c b return packed word--20
c t array to pack of char*1's
character*20 a,b
integer*4 ia(5)
equivalence (ia,a)
character*1 s(20),t(20)
do 95 i = 1,20
95 s(i)=t(i)
do 1 k = 1,5
ia(6-k)=0
do 1 j = 1, 4
l=4*(5-k)+5-j
ia(6-k) = ia(6-k) + ichar (s(l))
1 if (j.ne.4) ia(6-k) = ia(6-k) * 256
b=a
return
end
c
integer*2 function toting(obj)
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
dimension atloc(150),link(200),place( 100),fixed(100)
toting=0
if (place(obj).eq.-1) toting=1
return
end
c
integer*2 function here(obj)
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
common /loccom/ loc
dimension atloc(150),link(200),place( 100),fixed(100)
here=0
if (place(obj).eq.loc.or.toting(obj).eq.1) here=1
return
end
c
integer*2 function at(obj)
implicit integer*2 (a-z)
common /placom/ atloc,link,place,fixed,holdng
common /loccom/ loc
dimension atloc(150),link(200),place( 100),fixed(100)
at=0
if (place(obj).eq.loc.or.fixed(obj).eq.loc) at=1
return
end
c
integer*2 function forced(loc)
implicit integer*2 (a-z)
common /concom/ cond
dimension cond (150)
forced=0
if (cond(loc).eq.2) forced=1
return
end
c
integer*2 function dark(dummy)
implicit integer*2 (a-z)
common /concom/ cond
common /loccom/ loc
common /procom/ prop, lamp
dimension cond(150),prop(100)
external here
dark=0
if (mod(cond(loc),2).eq.0 .and. (prop(lamp).eq.0 .or.
. here(lamp).eq.0)) dark=1
return
end